home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / dlap.lisp < prev    next >
Lisp/Scheme  |  1992-12-21  |  25KB  |  640 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package :pcl)
  29.  
  30.  
  31.  
  32. (defun emit-one-class-reader (class-slot-p)
  33.   (emit-reader/writer :reader 1 class-slot-p))
  34.  
  35. (defun emit-one-class-writer (class-slot-p)
  36.   (emit-reader/writer :writer 1 class-slot-p))
  37.  
  38. (defun emit-two-class-reader (class-slot-p)
  39.   (emit-reader/writer :reader 2 class-slot-p))
  40.  
  41. (defun emit-two-class-writer (class-slot-p)
  42.   (emit-reader/writer :writer 2 class-slot-p))
  43.  
  44.  
  45.  
  46. (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
  47.   (let ((instance nil)
  48.     (arglist  ())
  49.     (closure-variables ())
  50.     (field (first-wrapper-cache-number-index))) 
  51.     ;;we need some field to do the fast obsolete check
  52.     (ecase reader/writer
  53.       (:reader (setq instance (dfun-arg-symbol 0)
  54.              arglist  (list instance)))
  55.       (:writer (setq instance (dfun-arg-symbol 1)
  56.              arglist  (list (dfun-arg-symbol 0) instance))))
  57.     (ecase 1-or-2-class
  58.       (1 (setq closure-variables '(wrapper-0 index miss-fn)))
  59.       (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
  60.     (generating-lap closure-variables
  61.             arglist
  62.        (with-lap-registers ((inst t)                   ;reg for the instance
  63.                 (wrapper #-structure-wrapper vector       ;reg for the wrapper
  64.                      #+structure-wrapper t)
  65.                 #+structure-wrapper (cnv fixnum-vector)
  66.                 (cache-no index))               ;reg for the cache no
  67.       (let ((index cache-no)                   ;This register is used
  68.                                    ;for different values at
  69.                                    ;different times.
  70.         (slots (and (null class-slot-p)
  71.                 (allocate-register #-new-kcl-wrapper 'vector
  72.                            #+new-kcl-wrapper t)))
  73.         (csv   (and class-slot-p
  74.                 (allocate-register t))))
  75.         (prog1 (flatten-lap
  76.              (opcode :move (operand :arg instance) inst)   ;get the instance
  77.              (opcode :std-instance-p inst 'std-instance)   ;if not either std-inst
  78.              (opcode :fsc-instance-p inst 'fsc-instance)   ;or fsc-instance then
  79.              (opcode :go 'trap)                   ;we lose
  80.  
  81.              (opcode :label 'fsc-instance)
  82.              (opcode :move (operand :fsc-wrapper inst) wrapper)
  83.              (and slots
  84.               (opcode :move (operand :fsc-slots inst) slots))
  85.              (opcode :go 'have-wrapper)
  86.  
  87.              (opcode :label 'std-instance)
  88.              (opcode :move (operand :std-wrapper inst) wrapper)
  89.              (and slots
  90.               (opcode :move (operand :std-slots inst) slots))
  91.  
  92.              (opcode :label 'have-wrapper)
  93.              #-structure-wrapper
  94.              (opcode :move (operand :cref wrapper field) cache-no)
  95.              #+structure-wrapper
  96.              (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
  97.              #+structure-wrapper
  98.              (opcode :move (operand :cref cnv field) cache-no)
  99.              (opcode :izerop cache-no 'trap)           ;obsolete wrapper?
  100.  
  101.              (ecase 1-or-2-class
  102.                (1 (emit-check-1-class-wrapper wrapper 'wrapper-0 'trap))
  103.                (2 (emit-check-2-class-wrapper wrapper 'wrapper-0 'wrapper-1 'trap)))
  104.              
  105.              (if class-slot-p
  106.              (flatten-lap
  107.               (opcode :move (operand :cvar 'index) csv)
  108.               (ecase reader/writer
  109.                (:reader (emit-get-class-slot csv 'trap inst))
  110.                (:writer (emit-set-class-slot csv (car arglist) inst))))
  111.                (flatten-lap
  112.             (opcode :move (operand :cvar 'index) index)
  113.             (ecase reader/writer
  114.                (:reader (emit-get-slot slots index 'trap inst))
  115.                (:writer (emit-set-slot slots index (car arglist) inst)))))
  116.           
  117.              (opcode :label 'trap)
  118.              (emit-miss 'miss-fn))
  119.           (when slots (deallocate-register slots))
  120.           (when csv (deallocate-register csv))))))))
  121.  
  122.  
  123.  
  124. (defun emit-one-index-readers (class-slot-p)
  125.   (let ((arglist (list (dfun-arg-symbol 0))))
  126.     (generating-lap '(field cache-vector mask size index miss-fn)
  127.             arglist
  128.       (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t))
  129.     (emit-dlap  arglist
  130.             '(standard-instance)
  131.             'trap
  132.             (with-lap-registers ((index index))
  133.               (flatten-lap
  134.             (opcode :move (operand :cvar 'index) index)
  135.             (if class-slot-p
  136.                 (emit-get-class-slot index 'trap slots)
  137.                 (emit-get-slot slots index 'trap))))
  138.             (flatten-lap
  139.               (opcode :label 'trap)
  140.               (emit-miss 'miss-fn))
  141.             nil
  142.             (and (null class-slot-p) (list slots)))))))
  143.  
  144. (defun emit-one-index-writers (class-slot-p)
  145.   (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))))
  146.     (generating-lap '(field cache-vector mask size index miss-fn)
  147.             arglist
  148.       (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t))
  149.     (emit-dlap arglist
  150.            '(t standard-instance)
  151.            'trap
  152.            (with-lap-registers ((index index))
  153.              (flatten-lap
  154.                (opcode :move (operand :cvar 'index) index)
  155.                (if class-slot-p
  156.                (emit-set-class-slot index (dfun-arg-symbol 0) slots)
  157.                (emit-set-slot slots index (dfun-arg-symbol 0)))))
  158.            (flatten-lap
  159.              (opcode :label 'trap)
  160.              (emit-miss 'miss-fn))
  161.            nil
  162.            (and (null class-slot-p) (list nil slots)))))))
  163.  
  164.  
  165.  
  166. (defun emit-n-n-readers ()
  167.   (let ((arglist (list (dfun-arg-symbol 0))))
  168.     (generating-lap '(field cache-vector mask size miss-fn)
  169.             arglist
  170.       (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t)
  171.                (index index))
  172.     (emit-dlap arglist
  173.            '(standard-instance)
  174.            'trap
  175.            (emit-get-slot slots index 'trap)
  176.            (flatten-lap
  177.              (opcode :label 'trap)
  178.              (emit-miss 'miss-fn))
  179.            index
  180.            (list slots))))))
  181.  
  182. (defun emit-n-n-writers ()
  183.   (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))))
  184.     (generating-lap '(field cache-vector mask size miss-fn)
  185.             arglist
  186.       (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t)
  187.                (index index))
  188.     (flatten-lap
  189.       (emit-dlap arglist
  190.              '(t standard-instance)
  191.              'trap
  192.              (emit-set-slot slots index (dfun-arg-symbol 0))
  193.              (flatten-lap
  194.                (opcode :label 'trap)
  195.                (emit-miss 'miss-fn))
  196.              index
  197.              (list nil slots)))))))
  198.   
  199.  
  200.  
  201. (defun emit-checking (metatypes applyp)
  202.   (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
  203.     (generating-lap '(field cache-vector mask size 
  204.               #-excl-sun4 emf #+excl-sun4 function 
  205.               miss-fn)
  206.             dlap-lambda-list
  207.       (emit-dlap (remove '&rest dlap-lambda-list)
  208.          metatypes         
  209.          'trap
  210.          (with-lap-registers ((#-excl-sun4 emf #+excl-sun4 function t))
  211.            (flatten-lap
  212.              (opcode :move (operand :cvar 
  213.                         #-excl-sun4 'emf #+excl-sun4 'function)
  214.                  #-excl-sun4 emf 
  215.                  #+excl-sun4 function)
  216.              #-excl-sun4 (opcode :emf-call emf)
  217.              #+excl-sun4 (opcode :jmp function)))
  218.          (with-lap-registers ((miss-function t))
  219.            (flatten-lap
  220.              (opcode :label 'trap)
  221.              (opcode :move (operand :cvar 'miss-fn) miss-function)
  222.              (opcode :jmp miss-function)))
  223.          nil))))
  224.  
  225. (defun emit-caching (metatypes applyp)
  226.   (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
  227.     (generating-lap '(field cache-vector mask size miss-fn)
  228.             dlap-lambda-list
  229.       (with-lap-registers ((#-excl-sun4 emf #+excl-sun4 function t))
  230.     (emit-dlap (remove '&rest dlap-lambda-list)
  231.            metatypes
  232.            'trap
  233.            (flatten-lap
  234.             #-excl-sun4 (opcode :emf-call emf)
  235.             #+excl-sun4 (opcode :jmp function))
  236.            (with-lap-registers ((miss-function t))
  237.              (flatten-lap
  238.                (opcode :label 'trap)
  239.                (opcode :move (operand :cvar 'miss-fn) miss-function)
  240.                (opcode :jmp miss-function)))
  241.            #-excl-sun4 emf #+excl-sun4 function)))))
  242.  
  243. (defun emit-constant-value (metatypes)
  244.   (let ((dlap-lambda-list (make-dlap-lambda-list metatypes nil)))
  245.     (generating-lap '(field cache-vector mask size miss-fn)
  246.             dlap-lambda-list
  247.       (with-lap-registers ((value t))
  248.     (emit-dlap dlap-lambda-list
  249.            metatypes
  250.            'trap
  251.            (flatten-lap
  252.              (opcode :return value))
  253.            (with-lap-registers ((miss-function t))
  254.              (flatten-lap
  255.                (opcode :label 'trap)
  256.                (opcode :move (operand :cvar 'miss-fn) miss-function)
  257.                (opcode :jmp miss-function)))
  258.            value)))))
  259.  
  260.  
  261.  
  262. (defun emit-check-1-class-wrapper (wrapper cwrapper-0 miss-label)
  263.   (with-lap-registers ((cwrapper #-structure-wrapper vector
  264.                  #+structure-wrapper t))
  265.     (flatten-lap
  266.      (opcode :move (operand :cvar cwrapper-0) cwrapper)
  267.      (opcode :neq wrapper cwrapper miss-label))))        ;wrappers not eq, trap
  268.  
  269. (defun emit-check-2-class-wrapper (wrapper cwrapper-0 cwrapper-1 miss-label)
  270.   (with-lap-registers ((cwrapper #-structure-wrapper vector
  271.                  #+structure-wrapper t))
  272.     (flatten-lap
  273.      (opcode :move (operand :cvar cwrapper-0) cwrapper)        ;This is an OR.  Isn't
  274.      (opcode :eq wrapper cwrapper 'hit-internal)        ;assembly code fun
  275.      (opcode :move (operand :cvar cwrapper-1) cwrapper)        ;
  276.      (opcode :neq wrapper cwrapper miss-label)            ;
  277.      (opcode :label 'hit-internal))))
  278.  
  279. (defun emit-get-slot (slots index trap-label &optional temp)
  280.   (let ((slot-unbound (operand :constant *slot-unbound*)))
  281.     (with-lap-registers ((val t :reuse temp))
  282.       (flatten-lap
  283.     (opcode :move (operand :instance-ref slots index) val)  ;get slot value
  284.     (opcode :eq val slot-unbound trap-label)        ;is the slot unbound?
  285.     (opcode :return val)))))                ;return the slot value
  286.  
  287. (defun emit-set-slot (slots index new-value-arg &optional temp)
  288.   (with-lap-registers ((new-val t :reuse temp))
  289.     (flatten-lap
  290.       (opcode :move (operand :arg new-value-arg) new-val)    ;get new value into a reg
  291.       (opcode :move new-val (operand :instance-ref slots index));set slot value
  292.       (opcode :return new-val))))
  293.  
  294. (defun emit-get-class-slot (index trap-label &optional temp)
  295.   (let ((slot-unbound (operand :constant *slot-unbound*)))
  296.     (with-lap-registers ((val t :reuse temp))
  297.       (flatten-lap
  298.     (opcode :move (operand :cdr index) val)
  299.     (opcode :eq val slot-unbound trap-label)
  300.     (opcode :return val)))))
  301.  
  302. (defun emit-set-class-slot (index new-value-arg &optional temp)
  303.   (with-lap-registers ((new-val t :reuse temp))
  304.     (flatten-lap
  305.       (opcode :move (operand :arg new-value-arg) new-val)
  306.       (opcode :move new-val (operand :cdr index))
  307.       (opcode :return new-val))))
  308.  
  309. (defun emit-miss (miss-fn)
  310.   (with-lap-registers ((miss-fn-reg t))
  311.     (flatten-lap
  312.      (opcode :move (operand :cvar miss-fn) miss-fn-reg)        ;get the miss function
  313.      (opcode :jmp miss-fn-reg))))                ;and call it
  314.  
  315.  
  316.  
  317. (defun dlap-wrappers (metatypes)
  318.   (mapcar #'(lambda (x) (and (neq x 't)
  319.                  (allocate-register #-structure-wrapper 'vector
  320.                         #+structure-wrapper t)))
  321.       metatypes))
  322.  
  323. (defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs)
  324.   (gathering1 (collecting)
  325.     (iterate ((mt (list-elements metatypes))
  326.           (arg (list-elements args))
  327.           (wrapper (list-elements wrappers))
  328.           (i (interval :from 0)))
  329.        (when wrapper
  330.          (gather1
  331.        (emit-fetch-wrapper mt arg wrapper miss-label (nth i slot-regs)))))))
  332.  
  333. (defun emit-dlap (args metatypes miss-label hit miss value-reg &optional slot-regs)
  334.   (let* ((wrappers (dlap-wrappers metatypes))
  335.      (nwrappers (remove nil wrappers))
  336.      (wrapper-moves (dlap-wrapper-moves wrappers args metatypes miss-label slot-regs)))
  337.     (prog1 (emit-dlap-internal nwrappers
  338.                    wrapper-moves
  339.                    hit
  340.                    miss
  341.                    miss-label
  342.                    value-reg)
  343.        (mapc #'deallocate-register nwrappers))))
  344.  
  345. (defun emit-dlap-internal (wrapper-regs wrapper-moves hit miss miss-label value-reg)
  346.   (cond ((cdr wrapper-regs)
  347.      (emit-greater-than-1-dlap
  348.        wrapper-regs wrapper-moves hit miss miss-label value-reg))
  349.     ((null value-reg)
  350.      (emit-1-nil-dlap
  351.        (car wrapper-regs) (car wrapper-moves) hit miss miss-label))
  352.     (t
  353.      (emit-1-t-dlap
  354.        (car wrapper-regs) (car wrapper-moves) hit miss miss-label value-reg))))
  355.  
  356.  
  357.  
  358. (defun emit-1-nil-dlap (wrapper wrapper-move hit miss miss-label)
  359.   (with-lap-registers ((location index)
  360.                (primary index)
  361.                (cache-vector vector))
  362.     (flatten-lap
  363.       wrapper-move
  364.       (opcode :move (operand :cvar 'cache-vector) cache-vector)
  365.       (with-lap-registers ((wrapper-cache-no index))
  366.     (flatten-lap
  367.       (emit-1-wrapper-compute-primary-cache-location wrapper primary wrapper-cache-no)
  368.       (opcode :move primary location)
  369.       (emit-check-1-wrapper-in-cache cache-vector location wrapper hit)       ;inline hit code
  370.       (opcode :izerop wrapper-cache-no miss-label)))
  371.       (with-lap-registers ((size index))
  372.     (flatten-lap
  373.       (opcode :move (operand :cvar 'size) size)
  374.       (opcode :label 'loop)
  375.       (opcode :move (operand :i1+ location) location)
  376.       (opcode :fix= location primary miss-label)
  377.       (opcode :fix= location size 'set-location-to-min)
  378.       (opcode :label 'continue)
  379.       (emit-check-1-wrapper-in-cache cache-vector location wrapper hit) 
  380.       (opcode :go 'loop)
  381.       (opcode :label 'set-location-to-min)
  382.       (opcode :izerop primary miss-label)
  383.       (opcode :move (operand :constant (index-value->index 0)) location)
  384.       (opcode :go 'continue)))
  385.       miss)))
  386.  
  387. ;;;
  388. ;;; The function below implements CACHE-VECTOR-LOCK-COUNT as the first entry 
  389. ;;; in a cache (svref cache-vector 0).  This should probably be abstracted.
  390. ;;;
  391. (defun emit-1-t-dlap (wrapper wrapper-move hit miss miss-label value)
  392.   (with-lap-registers ((location index)
  393.                (primary index)
  394.                (cache-vector vector)
  395.                (initial-lock-count t))
  396.     (flatten-lap
  397.       wrapper-move
  398.       (opcode :move (operand :cvar 'cache-vector) cache-vector)
  399.       (with-lap-registers ((wrapper-cache-no index))
  400.     (flatten-lap
  401.       (emit-1-wrapper-compute-primary-cache-location wrapper primary wrapper-cache-no)
  402.       (opcode :move primary location)
  403.       (opcode :move (operand :cref cache-vector 0) initial-lock-count)       ;get lock-count
  404.       (emit-check-cache-entry cache-vector location wrapper 'hit-internal)
  405.       (opcode :izerop wrapper-cache-no miss-label)))    ;check for obsolescence
  406.       (with-lap-registers ((size index))
  407.     (flatten-lap
  408.       (opcode :move (operand :cvar 'size) size)
  409.  
  410.       (opcode :label 'loop)
  411.       (opcode :move (operand :i1+ location) location)
  412.       (opcode :move (operand :i1+ location) location)
  413.       (opcode :label 'continue)
  414.       (opcode :fix= location primary miss-label)
  415.       (opcode :fix= location size 'set-location-to-min)
  416.       (emit-check-cache-entry cache-vector location wrapper 'hit-internal)
  417.       (opcode :go 'loop)
  418.  
  419.       (opcode :label 'set-location-to-min)
  420.       (opcode :izerop primary miss-label)
  421.       (opcode :move (operand :constant (index-value->index 2)) location)
  422.       (opcode :go 'continue)))
  423.       (opcode :label 'hit-internal)
  424.       (opcode :move (operand :i1+ location) location)           ;position for getting value
  425.       (opcode :move (emit-cache-vector-ref cache-vector location) value)
  426.       (emit-lock-count-test initial-lock-count cache-vector 'hit)
  427.       miss
  428.       (opcode :label 'hit)
  429.       hit)))
  430.  
  431. (defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value)
  432.   (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
  433.     (with-lap-registers ((location index)
  434.              (primary index)
  435.              (cache-vector vector)
  436.              (initial-lock-count t)
  437.              (next-location index)
  438.              (line-size index))    ;Line size holds a constant
  439.                         ;that can be folded in if there was
  440.                         ;a way to add a constant to 
  441.                         ;an index register
  442.       (flatten-lap
  443.     (apply #'flatten-lap wrapper-moves)
  444.     (opcode :move (operand :constant cache-line-size) line-size)
  445.     (opcode :move (operand :cvar 'cache-vector) cache-vector)
  446.     (emit-n-wrapper-compute-primary-cache-location wrappers primary miss-label)
  447.     (opcode :move primary location)
  448.     (opcode :move location next-location)
  449.     (opcode :move (operand :cref cache-vector 0) initial-lock-count)  ;get the lock-count
  450.     (with-lap-registers ((size index))
  451.       (flatten-lap
  452.         (opcode :move (operand :cvar 'size) size)
  453.         (opcode :label 'continue)
  454.         (opcode :move (operand :i+ location line-size) next-location)
  455.         (emit-check-cache-line cache-vector location wrappers 'hit)
  456.         (emit-adjust-location location next-location primary size 'continue miss-label)
  457.         (opcode :label 'hit)
  458.         (and value (opcode :move (emit-cache-vector-ref cache-vector location) value))
  459.         (emit-lock-count-test initial-lock-count cache-vector 'hit-internal)
  460.         miss
  461.         (opcode :label 'hit-internal)
  462.         hit))))))
  463.  
  464.  
  465.  
  466. ;;;
  467. ;;; Cache related lap code
  468. ;;;
  469.  
  470. (defun emit-check-1-wrapper-in-cache (cache-vector location wrapper hit-code)
  471.   (let ((exit-emit-check-1-wrapper-in-cache 
  472.       (make-symbol "exit-emit-check-1-wrapper-in-cache")))
  473.     (with-lap-registers ((cwrapper #-structure-wrapper vector
  474.                    #+structure-wrapper t))
  475.       (flatten-lap
  476.     (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper)
  477.     (opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache)
  478.     hit-code
  479.     (opcode :label exit-emit-check-1-wrapper-in-cache)))))
  480.  
  481. (defun emit-check-cache-entry (cache-vector location wrapper hit-label)
  482.   (with-lap-registers ((cwrapper #-structure-wrapper vector
  483.                  #+structure-wrapper t))
  484.     (flatten-lap
  485.       (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper)
  486.       (opcode :eq cwrapper wrapper hit-label))))
  487.  
  488. (defun emit-check-cache-line (cache-vector location wrappers hit-label)
  489.   (let ((checks
  490.       (flatten-lap
  491.         (gathering1 (flattening-lap)
  492.           (iterate ((wrapper (list-elements wrappers)))
  493.         (with-lap-registers ((cwrapper #-structure-wrapper vector
  494.                            #+structure-wrapper t))
  495.           (gather1
  496.             (flatten-lap
  497.               (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper)
  498.               (opcode :neq cwrapper wrapper 'exit-emit-check-cache-line)
  499.               (opcode :move (operand :i1+ location) location)))))))))
  500.     (flatten-lap
  501.       checks
  502.       (opcode :go hit-label)
  503.       (opcode :label 'exit-emit-check-cache-line))))
  504.  
  505. (defun emit-lock-count-test (initial-lock-count cache-vector hit-label)
  506.   ;;
  507.   ;; jumps to hit-label if cache-vector-lock-count consistent, otherwise, continues
  508.   ;; 
  509.   (with-lap-registers ((new-lock-count t))
  510.     (flatten-lap
  511.       (opcode :move (operand :cref cache-vector 0) new-lock-count) ;get new cache-vector-lock-count
  512.       (opcode :fix= new-lock-count initial-lock-count hit-label))))
  513.  
  514.  
  515.  
  516. (defun emit-adjust-location (location next-location primary size cont-label miss-label)
  517.   (flatten-lap
  518.     (opcode :move next-location location)
  519.     (opcode :fix= location size 'at-end-of-cache)
  520.     (opcode :fix= location primary miss-label)
  521.     (opcode :go cont-label)
  522.     (opcode :label 'at-end-of-cache)
  523.     (opcode :fix= primary (operand :constant (index-value->index 1)) miss-label)
  524.     (opcode :move (operand :constant (index-value->index 1)) location)
  525.     (opcode :go cont-label)))
  526.      
  527.  
  528. ;; From cache.lisp
  529. (defun emit-cache-vector-ref (cache-vector-operand location-operand)
  530.   (operand :iref cache-vector-operand location-operand))
  531.  
  532. (defun emit-wrapper-ref (wrapper-operand field-operand)
  533.   (operand :iref wrapper-operand field-operand))
  534.  
  535. (defun emit-wrapper-cache-number-vector (wrapper-operand)
  536.   (operand :wrapper-cache-number-vector wrapper-operand))
  537.  
  538. (defun emit-cache-number-vector-ref (cnv-operand field-operand)
  539.   (operand :iref cnv-operand field-operand))
  540.  
  541. (defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no)
  542.   (with-lap-registers ((mask index) 
  543.                #+structure-wrapper (cnv fixnum-vector))
  544.     (let ((field wrapper-cache-no))
  545.       (flatten-lap
  546.         (opcode :move (operand :cvar 'mask) mask)
  547.         (opcode :move (operand :cvar 'field) field)
  548.     #-structure-wrapper
  549.         (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
  550.     #+structure-wrapper
  551.     (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
  552.     #+structure-wrapper
  553.     (opcode :move (emit-cache-number-vector-ref cnv field) wrapper-cache-no)
  554.         (opcode :move (operand :ilogand wrapper-cache-no mask) primary)))))
  555.  
  556. (defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label)
  557.   (with-lap-registers ((field index)
  558.                (mask index))
  559.     (let ((add-wrapper-cache-numbers
  560.        (flatten-lap
  561.         (gathering1 (flattening-lap)
  562.            (iterate ((wrapper (list-elements wrappers))
  563.              (i (interval :from 1)))
  564.          (gather1
  565.           (with-lap-registers ((wrapper-cache-no index)
  566.                        #+structure-wrapper (cnv fixnum-vector))
  567.             (flatten-lap
  568.              #-structure-wrapper
  569.              (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
  570.              #+structure-wrapper
  571.              (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
  572.              #+structure-wrapper
  573.              (opcode :move (emit-cache-number-vector-ref cnv field)
  574.                  wrapper-cache-no)
  575.              (opcode :izerop wrapper-cache-no miss-label)
  576.              (opcode :move (operand :i+ primary wrapper-cache-no) primary)
  577.              (when (zerop (mod i wrapper-cache-number-adds-ok))
  578.                (opcode :move (operand :ilogand primary mask) primary))))))))))
  579.       (flatten-lap
  580.        (opcode :move (operand :constant 0) primary)
  581.        (opcode :move (operand :cvar 'field) field)
  582.        (opcode :move (operand :cvar 'mask) mask)
  583.        add-wrapper-cache-numbers
  584.        (opcode :move (operand :ilogand primary mask) primary)
  585.        (opcode :move (operand :i1+ primary) primary)))))
  586.  
  587. (defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot)
  588.   (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper")))
  589.     (with-lap-registers ((arg t))
  590.       (ecase metatype
  591.     ((standard-instance #+new-kcl-wrapper structure-instance)
  592.       (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
  593.         (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")))
  594.         (flatten-lap
  595.           (opcode :move (operand :arg argument) arg)
  596.           (opcode :std-instance-p arg get-std-inst-wrapper)       ;is it a std wrapper?
  597.           (opcode :fsc-instance-p arg get-fsc-inst-wrapper)       ;is it a fsc wrapper?
  598.           (opcode :go miss-label)
  599.           (opcode :label get-fsc-inst-wrapper)
  600.           (opcode :move (operand :fsc-wrapper arg) dest)       ;get fsc wrapper
  601.           (and slot
  602.            (opcode :move (operand :fsc-slots arg) slot))
  603.           (opcode :go exit-emit-fetch-wrapper)
  604.           (opcode :label get-std-inst-wrapper)
  605.           (opcode :move (operand :std-wrapper arg) dest)       ;get std wrapper
  606.           (and slot
  607.            (opcode :move (operand :std-slots arg) slot))
  608.           (opcode :label exit-emit-fetch-wrapper))))
  609.     (class
  610.       (when slot (error "Can't do a slot reg for this metatype."))
  611.       (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
  612.         (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")))
  613.         (flatten-lap
  614.           (opcode :move (operand :arg argument) arg)
  615.           (opcode :std-instance-p arg get-std-inst-wrapper)
  616.           (opcode :fsc-instance-p arg get-fsc-inst-wrapper)
  617.           #-new-kcl-wrapper
  618.           (opcode :move (operand :built-in-or-structure-wrapper arg) dest)
  619.           #+new-kcl-wrapper
  620.           (opcode :move (operand :built-in-wrapper arg) dest)
  621.           (opcode :go exit-emit-fetch-wrapper)
  622.           (opcode :label get-fsc-inst-wrapper)
  623.           (opcode :move (operand :fsc-wrapper arg) dest)
  624.           (opcode :go exit-emit-fetch-wrapper)
  625.           (opcode :label get-std-inst-wrapper)
  626.           (opcode :move (operand :std-wrapper arg) dest)
  627.           (opcode :label exit-emit-fetch-wrapper))))
  628.     ((built-in-instance #-new-kcl-wrapper structure-instance)
  629.       (when slot (error "Can't do a slot reg for this metatype."))
  630.       (let ()
  631.         (flatten-lap
  632.           (opcode :move (operand :arg argument) arg)
  633.           (opcode :std-instance-p arg miss-label)
  634.           (opcode :fsc-instance-p arg miss-label)
  635.           #-new-kcl-wrapper
  636.           (opcode :move (operand :built-in-or-structure-wrapper arg) dest)
  637.           #+new-kcl-wrapper
  638.           (opcode :move (operand :built-in-wrapper arg) dest))))))))
  639.  
  640.